home *** CD-ROM | disk | FTP | other *** search
/ CD Ware Multimedia 1995 May / cd Ware (Juegos) Epimundo.iso / DOS / PRGMMING / QUIKDB.ZIP / DBPAS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-11-17  |  28.3 KB  |  1,084 lines

  1. {$A+,B-,D+,E+,F+,I+,L+,N-,O+,R-,S+,V-}
  2. {$M 16384,0,655360}
  3.  
  4. UNIT DBPAS;
  5.  
  6. interface
  7.  
  8. uses crt,dos,getfield,screenio;
  9.  
  10. type
  11.   setc = record
  12.                prompt   : byte;
  13.                active   : byte;
  14.                inactive : byte;
  15.                shadow   : byte;
  16.                clear_chr: char;
  17.                EscKey   : boolean;
  18.                Clean    : boolean;
  19.                Confirm  : boolean;
  20.                Bell     : boolean;
  21.                UpDn     : boolean;
  22.                Wndw     : boolean;
  23.              end;
  24.   DB_Header = RECORD  (* dBASE file header *)
  25.                DBType    : Byte;
  26.                Year      : Byte;
  27.                Month     : Byte;
  28.                Day       : Byte;
  29.                RecCount  : LongInt;
  30.                Location  : Integer;
  31.                RecordLen : Integer;
  32.                Reserved  : Array[1..20] of Char;
  33.              END;
  34.   DB_Field = Record (* DBF field descriptors *)
  35.                FieldName    : Array[1..11] of Char;
  36.                FieldType    : char;
  37.                FieldAddress : LongInt;
  38.                FieldLen     : Byte;
  39.                FieldDec     : Byte;
  40.                Reserved     : Array[1..14] of Char;
  41.             END;
  42.   DB_GetDes= Record
  43.                Fstr : string;
  44.                Fnum : byte;
  45.                Area : byte;
  46.              END;
  47.   DB_Fld   = ^DB_Field;
  48.   DB_HDR   = ^DB_Header;
  49.   DBFObj   = ^DBF;
  50.   DB_GetD  = ^DB_GetDes;
  51.   filename = string[66];
  52.   str8     = string[8];
  53.   str4     = string[4];
  54.   str2     = string[2];
  55.  
  56.   DBF    = object
  57.     DBName  : FileName;
  58.     DBFile  : file;
  59.     maxflds : integer;
  60.     dberr   : word;
  61.     DBarea  : byte;
  62.     DB_GetF : byte;
  63.     CurrRec : longint;
  64.     _CHGREC : BOOLEAN;
  65.     _FOUND  : BOOLEAN;
  66.     _EXACT  : BOOLEAN;
  67.     _EOF    : BOOLEAN;
  68.     _BOF    : BOOLEAN;
  69.     _ONREC  : BOOLEAN;
  70.     _OK     : Boolean;
  71.     _Confirm: Boolean;
  72.     DBhdr   : DB_Header;
  73.     DBFld   : array[1..255] of DB_Fld;
  74.     DBRec   : array[1..4000] of char;
  75.     DB_FStr : array[1..255] of DB_GetD;
  76.     procedure ListHdr;
  77.     procedure writehdr;
  78.     procedure readhdr;
  79.     procedure writedbc(ch : char);
  80.  
  81.     procedure zap;
  82.     procedure recallall;
  83.     procedure pack;
  84.     procedure recallrec(RecNum : longint);
  85.     procedure deleterec(RecNum : longint);
  86.     procedure FRESHEN;
  87.     procedure CopySto(Fname : string);
  88.  
  89.     function  GetFld(Fnum : Byte) : string;
  90.     procedure replfld(Fnum : Byte;FStr : string);
  91.     procedure SayXY(xpos,ypos,fldnum : byte);
  92.     procedure GetXY(xpos,ypos,fldnum : byte;SayStr,Pix : string);
  93.     procedure GotoRec(RecNum : longint);
  94.     procedure appendblank;
  95.  
  96.     function  recno : longint;
  97.     function  reccount : longint;
  98.     function  deleted : boolean;
  99.  
  100.     procedure skip;
  101.     function  Continue(fnum : byte;FldStr : string) : boolean;
  102.     function  Locate(fnum : byte;FldStr : string) : boolean;
  103.  
  104.     procedure List;
  105.     procedure ListDB;
  106.     procedure DB_Stat;
  107.  
  108.     procedure NewField(FldName : string;Typ : char;Len,Dec : Byte);
  109.     procedure DoBrowseX(Title,BoxDef : string;TopX,TopY,BotX,BotY,Shadow,Border,WindC,Highbar : byte);
  110.     procedure DoBrowse(X,Y : byte);
  111.   end;
  112.  
  113. procedure pause;
  114. function  ctod(dates : str8) : string;
  115. function  dtoc(dates : str8) : string;
  116. function  Upper(str : string): string;
  117. function  CurrDate : string;
  118. function  StrToNum(Str : String) : integer;
  119. procedure ReadGet;
  120. procedure OpenDB(VAR DB : DBFobj;fname : string);
  121. function  CreateDB(VAR DB : DBFobj;fname : string) : boolean;
  122. procedure CloseDB(VAR DB : DBFobj);
  123.  
  124.  
  125. var
  126.   Max_GetF : byte;
  127.   SelectDB : array[1..255] of dbfobj;
  128.   Max_DB : byte;
  129.   SetColor : array[1..5] of setc;
  130.  
  131. implementation
  132.  
  133. var
  134.   Get_Rd : array[1..255] of byte;
  135.  
  136. procedure InitVar(VAR DB : DBFobj);
  137.   begin
  138.     DB^.CurrRec := 0;
  139.     DB^.MaxFlds := 0;
  140.     DB^._EXACT  := False;
  141.     DB^._eof    := False;
  142.     DB^._Bof    := False;
  143.     DB^._OnRec  := False;
  144.     DB^._FOUND  := False;
  145.     DB^._CHGREC := False;
  146.     DB^._Confirm:= False;
  147.     DB^.DB_GetF := 0;
  148.   end;
  149.  
  150. procedure InitDB(VAR db : DbfObj);
  151.   begin
  152.     New(DB);
  153.     inc(Max_DB);
  154.     InitVar(DB);
  155.     DB^.DBArea := Max_DB;
  156.     SelectDB[Max_DB] := DB;
  157.   end;
  158.  
  159. procedure DBF.writedbc(ch : char);
  160.   begin
  161.     blockwrite(dbfile,ch,1,dberr);
  162.   end;
  163.  
  164. function dtoc(dates : str8) : string;
  165.   var
  166.     month : str2;
  167.     day   : str2;
  168.     year  : str4;
  169.     m,d   : byte;
  170.     code  : integer;
  171.   begin
  172.     dtoc := '        ';
  173.     if length(dates) = 8 then
  174.       begin
  175.         month := copy(dates,5,2);
  176.         day   := copy(dates,7,2);
  177.         year  := copy(dates,3,2);
  178.         Val(Month,m,code);
  179.         Val(day  ,d,code);
  180.         if (m > 0) and (m < 13) then
  181.           if (d > 0) and (d < 32) then
  182.             dtoc  := month+'/'+day+'/'+year;
  183.       end;
  184.   end;
  185.  
  186. function ctod(dates : str8) : string;
  187.   var
  188.     month : str2;
  189.     day   : str2;
  190.     year  : str4;
  191.     m,d   : byte;
  192.     code : integer;
  193.   begin
  194.     ctod := '        ';
  195.     if length(dates) = 8 then
  196.       begin
  197.         month := copy(dates,1,2);
  198.         day   := copy(dates,4,2);
  199.         year  := '19' + copy(dates,7,2);
  200.         Val(Month,m,code);
  201.         Val(day  ,d,code);
  202.         if (m > 0) and (m < 13) then
  203.           if (d > 0) and (d < 32) then
  204.             ctod := year+month+day;
  205.       end;
  206.   end;
  207.  
  208. function Upper(str : string) : string;
  209.   var
  210.     count : byte;
  211.   begin
  212.     for count := 1 to length(str) do
  213.       str[count] := UpCase(str[count]);
  214.     Upper := str;
  215.   end;
  216.  
  217. function CurrDate : string;
  218.   var
  219.     y, m, d, dow : Word;
  220.     ys,ms,ds : string[4];
  221.   begin
  222.     GetDate(y,m,d,dow);
  223.     Str(y,ys);
  224.     Str(m,ms);
  225.     Str(d,ds);
  226.     NumStr(ms,2,0);
  227.     NumStr(ds,2,0);
  228.     NumStr(ys,2,0);
  229.     if m < 10 then ms[1] := '0';
  230.     if d < 10 then ds[1] := '0';
  231.     CurrDate := dtoc(ys+ms+ds);
  232.   end;
  233.  
  234. function CharToStr(input : array of char) : string;
  235.   var
  236.     count : integer;
  237.     str : string;
  238.   begin
  239.     count := 0;
  240.     str := '';
  241.     repeat
  242.       str := str+input[count];
  243.       inc(count);
  244.     until input[count] = #0;
  245.     CharToStr := str;
  246.   end;
  247.  
  248. procedure StrToChar(input : string;VAR output : array of char;FChar : char);
  249.   var
  250.     count : integer;
  251.   begin
  252.     fillchar(output,SizeOf(output),FChar);
  253.     for count := 1 to length(input) do
  254.       output[count-1] := input[count];
  255.   end;
  256.  
  257. procedure dbf.WriteHdr;
  258.   var
  259.     y, m, d, dow : Word;
  260.     count : byte;
  261.     nullc : char;
  262.     reclen : longint;
  263.   begin
  264.     reset(dbfile,1);
  265.     reclen := 1;
  266.     GetDate(y,m,d,dow);
  267.     dow := y;
  268.     dec(dow,50);
  269.     dec(y,round(dow/100)*100);
  270.     for count := 1 to MaxFlds do
  271.       inc(reclen,dbfld[count]^.FieldLen);
  272.     with dbhdr do
  273.       begin
  274.         dbtype    := 3;
  275.         year      := y;
  276.         month     := m;
  277.         day       := d;
  278.         location  := MaxFlds*32+33;
  279.         recordlen := RecLen;
  280.         if FileSize(DBfile) > location then reccount  := round((FileSize(DBfile)-Location)/recordlen)
  281.           else reccount := 0;
  282.         FillChar(reserved,SizeOf(reserved),#0);
  283.       end;
  284.     blockwrite(DBfile,dbhdr,SizeOf(dbhdr),dberr);
  285.     for count := 1 to MaxFlds do
  286.       begin
  287.         if count = 1 then dbfld[count]^.FieldAddress := 1
  288.           else dbfld[count]^.FieldAddress := dbfld[count-1]^.FieldAddress+dbfld[count-1]^.FieldLen;
  289.         blockwrite(DBfile,dbfld[count]^,SizeOf(dbfld[count]^),dberr);
  290.       end;
  291.     if dbhdr.reccount > 0 then writedbc(#13)
  292.       else writedbc(#0);
  293.   end;
  294.  
  295. procedure CloseDB(VAR DB : DBFobj);
  296.   var
  297.     count : byte;
  298.   begin
  299.     DB^.WriteHdr;
  300.     for count := DB^.MaxFlds downto 1 do
  301.       dispose(DB^.dbfld[count]);
  302.     close(DB^.dbfile);
  303.   end;
  304.  
  305. procedure dbf.readhdr;
  306.   var
  307.     fnum : byte;
  308.     fpos,sz : longint;
  309.   begin
  310.     reset(dbfile,1);
  311.     blockread(DBfile,dbhdr,SizeOf(dbhdr),dberr);
  312.     for fnum := 1 to MaxFlds do
  313.       Dispose(dbfld[Fnum]);
  314.     MaxFlds := (dbhdr.location-SizeOf(dbhdr)) div SizeOf(DB_Field);
  315.     for fnum := 1 to MaxFlds do
  316.       begin
  317.         New(dbfld[Fnum]);
  318.         blockread(DBfile,dbfld[Fnum]^,SizeOf(dbfld[Fnum]^),dberr);
  319.       end;
  320.   end;
  321.  
  322. function DBF.deleted : boolean;
  323.   begin
  324.     _CHGREC := True;
  325.     if DBRec[1] = '*' then deleted := TRUE
  326.       else deleted := FALSE;
  327.   end;
  328.  
  329. procedure DBF.GotoRec(RecNum : longint);
  330.   var
  331.     Fpos : longint;
  332.   begin
  333.     {$I-}
  334.     Seek(DBfile,dbhdr.location+((recnum-1)*dbhdr.recordlen));
  335.     {$I+}
  336.     if IOResult = 0 then
  337.       begin
  338.         _BOF   := FALSE;
  339.         _EOF   := FALSE;
  340.         _ONREC := TRUE;
  341.         Fpos := FilePos(DBfile);
  342.         blockread(DBfile,DBRec,dbhdr.recordlen,dberr);
  343.         if dberr = dbhdr.recordlen then _FOUND := TRUE else _FOUND := False;
  344.         if _FOUND then CurrRec := RecNum
  345.           else begin
  346.                  if RecNum > 0 then _EOF := TRUE else _BOF := TRUE;
  347.                  CurrRec := 0;
  348.                end;
  349.         Seek(DBfile,Fpos);
  350.       end else begin
  351.                  if RecNum > 0 then _EOF := TRUE else _BOF := TRUE;
  352.                  _ONREC := FALSE;
  353.                end;
  354.   end;
  355.  
  356. procedure DBF.DB_Stat;
  357.   var
  358.     count : byte;
  359.   begin
  360.     clrscr;
  361.     count := 1;
  362.     writeln;
  363.     writeln('  Name      Type  Address  Length  Decimals   Reserved      ');
  364.     writeln('-----------  -    -------  ---       ---      --------------');
  365.     for count := 1 to MaxFlds do
  366.       with dbfld[count]^ do
  367.         writeln(fieldname:11,'  ',FieldType:1,FieldAddress:11,FieldLen:5,FieldDec:10,Reserved:20);
  368.       writeln;
  369.       with dbhdr do
  370.         begin
  371.           gotoxy(50,6);  writeln('Database Statistics');
  372.           gotoxy(50,7);  writeln('------------------------------');
  373.           gotoxy(50,8);  writeln('Type.......... ',DBType);
  374.           gotoxy(50,9);  writeln('Last Update... ',Month,'/',day,'/',year);
  375.           gotoxy(50,10);  writeln('Record Length. ',Recordlen);
  376.           gotoxy(50,11); writeln('Records....... ',reccount);
  377.           gotoxy(50,12); writeln('Start Offset.. ',location);
  378.           gotoxy(50,13); writeln('Reserved...... ',reserved);
  379.         end;
  380.       gotoxy(1,24);
  381.   end;
  382.  
  383. function CreateDB(VAR DB : DBFobj;fname : string) : boolean;
  384.   begin
  385.     InitDB(DB);
  386.  {$I-}
  387.     DB^._CHGREC := True;
  388.     Assign(DB^.DBfile, fname);
  389.     Rewrite(DB^.DBfile,1);
  390.     DB^.dbname := fname;
  391.  {$I+}
  392.     if (IOResult = 0) and (fname <> '') then CreateDB := True
  393.       else CreateDB := False;
  394.   end;
  395.  
  396. procedure OpenDB(VAR DB : DBFobj;fname : string);
  397.   begin
  398.     InitDB(DB);
  399.     Assign(DB^.DBfile, fname);
  400.  {$I-}
  401.     Reset(DB^.DBfile,1);
  402.  {$I+}
  403.     if (IOResult = 0) and (fname <> '') then
  404.       begin
  405.         DB^.dbname := fname;
  406.         DB^.readhdr;
  407.         DB^.GotoRec(1);
  408.         DB^._OK := TRUE;
  409.       end else DB^._OK := FALSE;
  410.   end;
  411.  
  412. procedure DBF.NewField(FldName : string;Typ : char;Len,Dec : Byte);
  413.   var
  414.     count : byte;
  415.  
  416.   begin
  417.     _CHGREC := True;
  418.     inc(MaxFlds,1);
  419.     New(dbfld[MaxFlds]);
  420.     with dbfld[MaxFlds]^ do
  421.       begin
  422.         for count := 1 to length(FldName) do
  423.           FldName[count] := UpCase(Fldname[count]);
  424.         StrToChar(fldname,FieldName,#0);
  425.         if typ = 'D' then len := 8;
  426.         FieldType    := Typ;
  427.         FieldLen     := Len;
  428.         FieldDec     := Dec;
  429.         FillChar(reserved,SizeOf(reserved),#0);
  430.       end;
  431.     WriteHdr;
  432.   end;
  433.  
  434. procedure TrimStr(VAR InputStr : string);
  435.   var
  436.     count  : byte;
  437.   begin
  438.     count := Length(InputStr);
  439.     while (InputStr[count] = ' ') and (count > 0) do
  440.       begin
  441.         Delete(InputStr,count,1);
  442.         dec(count);
  443.       end;
  444.     while (InputStr[1] = ' ') and (Length(InputStr) > 0) do
  445.       Delete(InputStr,1,1);
  446.   end;
  447.  
  448. function StrToNum(Str : string) : integer;
  449.   var
  450.     Code,Num : integer;
  451.   begin
  452.     TrimStr(Str);
  453.     Val(Str,Num,Code);
  454.     if code > 0 then
  455.       Num := 0;
  456.     StrToNum := Num;
  457.   end;
  458.  
  459. procedure FillStr(VAR InputStr : string;count : byte);
  460.   begin
  461.     while length(InputStr) < count do
  462.       InputStr := InputStr + ' ';
  463.   end;
  464.  
  465. procedure DBF.FRESHEN;
  466.   begin
  467.     rewrite(DBfile);
  468.     writehdr;
  469.   end;
  470.  
  471. procedure DBF.deleterec(RecNum : longint);
  472.   var
  473.     FPos  : Longint;
  474.   begin
  475.     GotoRec(RecNum);
  476.     if _FOUND then
  477.       begin
  478.         _CHGREC := True;
  479.         Fpos := FilePos(DBfile);
  480.         writedbc(#42);
  481.         Seek(DBfile,Fpos);
  482.       end;
  483.   end;
  484.  
  485. procedure DBF.recallrec(RecNum : longint);
  486.   var
  487.     FPos  : Longint;
  488.   begin
  489.     GotoRec(RecNum);
  490.     if _FOUND then
  491.       begin
  492.         _CHGREC := True;
  493.         Fpos := FilePos(DBfile);
  494.         writedbc(#32);
  495.         Seek(DBfile,Fpos);
  496.       end;
  497.   end;
  498.  
  499. procedure DBF.replfld(Fnum : Byte;FStr : string);
  500.   var
  501.     FPos  : Longint;
  502.     code : integer;
  503.     NewStr : String;
  504.     count : byte;
  505.     RealInt : Real;
  506.     DBBuff  : array[0..1000] of char;
  507.   begin
  508.     if _ONREC then
  509.       begin
  510.         _CHGREC := True;
  511.         Fpos := FilePos(DBfile);
  512.         Seek(DBfile,Fpos+dbfld[fnum]^.FieldAddress);
  513.         TrimStr(Fstr);
  514.         case dbfld[Fnum]^.FieldType of
  515.           'N' : begin
  516.                   Val(Fstr,RealInt,code);
  517.                   Str(RealInt:dbfld[fnum]^.FieldLen:dbfld[fnum]^.FieldDec,Fstr);
  518.                   if dbfld[fnum]^.FieldDec > 0 then
  519.                     if Pos('.',Fstr) <> dbfld[fnum]^.FieldLen-dbfld[fnum]^.FieldDec then
  520.                       FillChar(Fstr,SizeOf(Fstr),'*');
  521.                 end;
  522.           'D' : begin
  523.                 end;
  524.         end;
  525.         strtochar(Fstr,DBBuff,' ');
  526.         blockwrite(DBfile,DBBuff,dbfld[fnum]^.FieldLen,dberr);
  527.         Seek(DBfile,Fpos);
  528.       end;
  529.   end;
  530.  
  531. function DBF.GetFld(Fnum : Byte) : string;
  532.   var
  533.     count : longint;
  534.     TempFld : string;
  535.   begin
  536.     TempFld := '';
  537.     if CurrRec > 0 then
  538.       begin
  539.         for count := 1 to dbfld[fnum]^.FieldLen do
  540.           TempFld := TempFld + DBRec[count+dbfld[Fnum]^.Fieldaddress];
  541.         Trimstr(TempFld);
  542.         GetFld := TempFld;
  543.       end;
  544.   end;
  545.  
  546. procedure DBF.zap;
  547.   var
  548.     count : longint;
  549.   begin
  550.     for count := 1 to dbhdr.reccount do
  551.       deleterec(count);
  552.     GotoRec(1);
  553.   end;
  554.  
  555. procedure DBF.recallall;
  556.   var
  557.     count : longint;
  558.   begin
  559.     for count := 1 to dbhdr.reccount do
  560.       recallrec(count);
  561.     GotoRec(1);
  562.   end;
  563.  
  564. procedure DBF.appendblank;
  565.   var
  566.     reclen : longint;
  567.     FPos   : longint;
  568.     count  : byte;
  569.     DBBuff : array[1..4000] of char;
  570.   begin
  571.     _CHGREC := True;
  572.     GotoRec(dbhdr.reccount+1);
  573.     Fpos := FilePos(DBfile);
  574.     reclen := 1;
  575.     for count := 1 to MaxFlds do
  576.       inc(reclen,dbfld[count]^.FieldLen);
  577.     fillchar(DBBuff,SizeOf(DBBuff),#32);
  578.     blockwrite(DBfile,DBBuff,reclen,dberr);
  579.     writedbc(#26);
  580.     inc(dbhdr.reccount);
  581.     CurrRec := dbhdr.reccount;
  582.     seek(DBfile,Fpos);
  583.   end;
  584.  
  585. function DBF.recno : longint;
  586.   begin
  587.     recno := round((FilePos(DBfile)-dbhdr.location)/dbhdr.recordlen)+1;
  588.   end;
  589.  
  590. function DBF.reccount : longint;
  591.   begin
  592.     reccount := round((FileSize(DBfile)-dbhdr.location)/dbhdr.recordlen);
  593.   end;
  594.  
  595. procedure Pause;
  596.   var
  597.     ch : word;
  598.   begin
  599.     write('Press any key to continue or ESC to exit...');
  600.     ch := Get_Key;
  601.   end;
  602.  
  603. procedure DBF.skip;
  604.   begin
  605.     inc(currrec);
  606.     gotorec(currrec);
  607.   end;
  608.  
  609. function DBF.Continue(fnum : byte;FldStr : string) : boolean;
  610.   var
  611.     recnum : longint;
  612.     fns : string;
  613.     OK : Boolean;
  614.   begin
  615.     OK := False;
  616.     recnum := currrec;
  617.     FldStr := Upper(FldStr);
  618.     inc(recnum);
  619.     GotoRec(recnum);
  620.     if _FOUND then
  621.       repeat
  622.         fns := Upper(getfld(fnum));
  623.         case _EXACT of
  624.           TRUE  : if fns = FldStr then OK := TRUE else inc(recnum);
  625.           FALSE : if Pos(FldStr,fns) > 0 then OK := TRUE else inc(recnum);
  626.         end;
  627.         GotoRec(recnum);
  628.         IF _FOUND = FALSE then OK := TRUE;
  629.       until OK;
  630.     if _FOUND = TRUE then Continue := TRUE
  631.       else Continue := FALSE;
  632.   end;
  633.  
  634. function DBF.Locate(fnum : byte;FldStr : string) : boolean;
  635.   var
  636.     fns : string;
  637.     recnum : longint;
  638.     OK : Boolean;
  639.   begin
  640.     recnum := 1;
  641.     TrimStr(FldStr);
  642.     FldStr := Upper(FldStr);
  643.     OK := False;
  644.     GotoRec(recnum);
  645.     if _FOUND then
  646.       repeat
  647.         fns := Upper(getfld(fnum));
  648.         case _EXACT of
  649.           TRUE  : if fns = FldStr then OK := TRUE else inc(recnum);
  650.           FALSE : if Pos(FldStr,fns) > 0 then OK := TRUE else inc(recnum);
  651.         end;
  652.         GotoRec(recnum);
  653.         IF _FOUND = FALSE then OK := TRUE;
  654.       until OK;
  655.     if _FOUND = TRUE then Locate := TRUE
  656.       else Locate := FALSE;
  657.   end;
  658.  
  659. procedure dbf.listhdr;
  660.   var
  661.     count : longint;
  662.     recnum : longint;
  663.     str : string;
  664.   begin
  665.     for count := 1 to MaxFlds do
  666.       with dbfld[count]^ do
  667.         if (FieldType = 'C') or (FieldType = 'D') then
  668.           begin
  669.             str := CharToStr(Fieldname);
  670.             FillStr(str,FieldLen);
  671.             str[0] := Chr(FieldLen);
  672.             write(' ',str)
  673.           end else write(' ',CharToStr(Fieldname):FieldLen);
  674.     writeln;
  675.     for count := 1 to MaxFlds do
  676.       begin
  677.         write(' ');
  678.         with dbfld[count]^ do
  679.           for recnum := 1 to FieldLen do
  680.             write('-');
  681.       end;
  682.   end;
  683.  
  684. procedure DBF.List;
  685.   var
  686.     count : longint;
  687.     recnum : longint;
  688.     str : string;
  689.   begin
  690.     ListHdr;
  691.     for recnum := 1 to dbhdr.reccount do
  692.       begin
  693.         gotorec(recnum);
  694.         if whereY >= 24 then
  695.           begin
  696.             writeln;
  697.             pause;
  698.             clrscr;
  699.             ListHdr;
  700.           end;
  701.         writeln;
  702.         for count := 1 to MaxFlds do
  703.           with dbfld[count]^ do
  704.             if (FieldType = 'C') or (FieldType = 'D') then
  705.               begin
  706.                 str := GetFld(count);
  707.                 FillStr(str,FieldLen);
  708.                 if FieldType = 'C' then write(' ',str)
  709.                   else write(' ',dtoc(str));
  710.               end else write(' ',GetFld(count):FieldLen);
  711.       end;
  712.     writeln;
  713.   end;
  714.  
  715. procedure DBF.ListDB;
  716.   var
  717.     recnum : longint;
  718.     count  : byte;
  719.     ch     : WORD;
  720.   begin
  721.     recnum := 1;
  722.     ch := 0;
  723.     Gotorec(1);
  724.     while ch <> 27 do
  725.       begin
  726.         If _ONREC = TRUE then
  727.           begin
  728.             clrscr;
  729.             GotoRec(RecNum);
  730.             write('DATABASE: ',DBname,'      Record Number ',recno,' of ',reccount,'    ');
  731.             if Deleted then writeln('DELETED')
  732.               else writeln;
  733.             writeln('-----------------------------------------------------');
  734.             for count := 1 to MaxFlds do
  735.               WriteLn(dbfld[count]^.FieldName:12,' : ',GetFld(count));
  736.             writeln('-----------------------------------------------------');
  737.             write('Press any key to continue or ESC to exit...');
  738.           end;
  739.         ch := Get_Key;
  740.         case ch of
  741.           _DN   : if recnum < dbhdr.reccount then inc(recnum);
  742.           _UP   : if recnum > 1 then dec(recnum);
  743.           _HOME : recnum := 1;
  744.           _END  : recnum := dbhdr.reccount;
  745.           _F1   : deleterec(recnum);
  746.           _F2   : recallrec(recnum);
  747.         end;
  748.       end;
  749.   end;
  750.  
  751. procedure DBF.CopySto(Fname : string);
  752.   var
  753.     TempDB : DBFobj;
  754.     count  : byte;
  755.     TMaxDB : byte;
  756.   begin
  757.     TMaxDB := Max_DB;
  758.     CreateDB(TempDB,fname);
  759.     for count := 1 to MaxFldS do
  760.       with dbfld[count]^ do
  761.         TempDB^.NewField(Fieldname,FieldType,FieldLen,FieldDec);
  762.     CloseDB(TempDB);
  763.     Max_DB := TMaxDB;
  764.   end;
  765.  
  766. procedure DBF.pack;
  767.   var
  768.     TempDB,
  769.     TempDB2 : DBFobj;
  770.     count  : byte;
  771.     fn,fext : string;
  772.     fname : string;
  773.     dfile : file;
  774.     TMaxDB : byte;
  775.   begin
  776.     TMaxDB := Max_DB;
  777.     fext := '';
  778.     if Pos('.',DBname) > 0 then
  779.       begin
  780.         fn   := Copy(DBname,1,Pos('.',DBname)-1);
  781.         fext := Copy(DBname,Pos('.',DBname),Length(DBname)-Pos('.',DBname)+1);
  782.       end else fn := DBname;
  783.     Assign(dfile,fn+'.bak');
  784.     {$I-}
  785.     erase(dfile);
  786.     {$I+}
  787.     Assign(dfile,fn+'.ba1');
  788.     {$I-}
  789.     erase(dfile);
  790.     {$I+}
  791.     CopySto(fn+'.ba1');
  792.     OpenDB(TempDB,fn+'.ba1');
  793.     GotoRec(1);
  794.     while not _eof do
  795.       begin
  796.         if not deleted then
  797.           begin
  798.             TempDB^.AppendBlank;
  799.             for count := 1 to MaxFlds do
  800.               TempDB^.replfld(count,GetFld(count));
  801.           end;
  802.         skip;
  803.       end;
  804.     CloseDB(TempDB);
  805.     Close(dbfile);
  806.     Assign(dfile,fn+fext);
  807.     {$I-}
  808.     rename(dfile,fn+'.bak');
  809.     {$I+}
  810.     Assign(dfile,fn+'.ba1');
  811.     {$I-}
  812.     rename(dfile,fn+'.dbf');
  813.     Assign(dbfile,fn+fext);
  814.     Reset(dbfile);
  815.     {$I+}
  816.     ReadHdr;
  817.     Max_DB := TMaxDB;
  818.   end;
  819.  
  820.  
  821. procedure dbf.DoBrowseX(Title,BoxDef : string;TopX,TopY,BotX,BotY,Shadow,Border,WindC,HighBar : byte);
  822.   var
  823.     TempStr : array[1..20] of string;
  824.     tstr  : string;
  825.     returnval,recnum : integer;
  826.     x,y,count,Size,DispRecs,int,NumFlds,oldattr : byte;
  827.     tp : char;
  828.     OLDX,OLDY : BYTE;
  829.     scrn : array[1..2000] of word;
  830.  
  831.   procedure DispFlds;
  832.     var
  833.      count,int : byte;
  834.      oldattr : byte;
  835.     begin
  836.       oldattr := textattr;
  837.       x := TopX+1;
  838.       Y := TopY+1;
  839.       textattr := windc;
  840.       for count := 1 to NumFlds do
  841.         begin
  842.           tstr := dbfld[count]^.FieldName;
  843.           for int := 1 to (dbfld[count]^.FieldLen-Length(tstr)) do
  844.             tstr := tstr+' ';
  845.           tstr := Copy(tstr,1,dbfld[count]^.FieldLen);
  846.           writeXY(x,y,tstr);
  847.           if WhereX < BotX then write('│');
  848.           for int := 1 to dbfld[count]^.FieldLen do
  849.             writeXY(x+int-1,y+1,'─');
  850.           x := x + dbfld[count]^.FieldLen+1;
  851.         end;
  852.       textattr := oldattr;
  853.     end;
  854.  
  855.   procedure DispSingleRec(var x,y,textc : byte;Readflds : boolean);
  856.     var
  857.       Count,Len,FldNumbr : byte;
  858.       Tstr,Pix : string;
  859.     begin
  860.       SetUp_Field($0E,textc,windc,$00,' ',TRUE,TRUE,_Confirm,TRUE,False,false);
  861.       for count := 1 to NumFlds do
  862.         begin
  863.           TempStr[count] := GetFld(count);
  864.           if dbfld[count]^.FieldDec < 10 then Str(dbfld[count]^.FieldDec:1,Tstr)
  865.             else Str(dbfld[count]^.FieldDec:2,Tstr);
  866.           Len := dbfld[count]^.FieldLen;
  867.           if dbfld[count]^.fieldtype = 'D' then
  868.             TempStr[count] := dtoc(TempStr[count]);
  869.           case dbfld[count]^.fieldtype of
  870.            'C' : Pix := '';
  871.            'N' : Pix := '@9:'+Tstr;
  872.            'D' : Pix := '@D';
  873.           end;
  874.           Field_Str(x,y,Len,'',TempStr[count],Pix);
  875.           x := x + Len+1;
  876.           if x-1 < BotX then writexy(x-1,y,'│');
  877.         end;
  878.       if readflds then Do_Fields(ReturnVal)
  879.         else Release_Fields;
  880.     end;
  881.  
  882.   procedure DispAllRecs;
  883.     var
  884.       recNum : Byte;
  885.     begin
  886.       x := TopX+1;
  887.       y := TopY+2;
  888.       for recnum := 1 to reccount do
  889.         if recnum <= DispRecs then begin
  890.           x := TopX+1;
  891.           y := y + 1;
  892.           GotoRec(RecNum);
  893.           DispSingleRec(x,y,windc,FALSE);
  894.         end;
  895.     end;
  896.  
  897.   procedure CheckKeys(Var x,y : byte);
  898.     begin
  899.       case ReturnVal of
  900.         _UP : begin
  901.                 if recnum > 1 then
  902.                   begin
  903.                     dec(recnum);
  904.                     if Y = TopY+3 then
  905.                        Scroll('D',1,$30,TopX+1,TopY+3,BotX-1,BotY-1)
  906.                     else Y := Y - 1;
  907.                   end;
  908.               end;
  909.         _DN : begin
  910.                 if recnum < reccount then
  911.                   begin
  912.                     inc(recnum);
  913.                     if Y < BotY-1 then Y := Y + 1
  914.                       else begin
  915.                              Scroll('U',1,$30,TopX+1,TopY+3,BotX-1,BotY-1);
  916.                            end;
  917.                   end;
  918.               end;
  919.       end;
  920.     end;
  921.  
  922.   begin
  923.     if reccount > 0 then
  924.     begin
  925.     oldx := WhereX;
  926.     oldy := WhereY;
  927.     if shadow > 0 then begin
  928.                          dec(BotX,2);
  929.                          dec(BotY,1);
  930.                        end;
  931.     if (_BOF) or (_EOF) then GotoRec(1);
  932.     Field_Id := 1;
  933.     oldattr := textattr;
  934.     NumFlds := MaxFlds;
  935.     if BotX-TopX-2-(NumFlds-1) < dbhdr.recordlen+(NumFlds-1) then
  936.       begin
  937.         count := 0;
  938.         NumFlds := 0;
  939.         while count < BotX-TopX do
  940.           begin
  941.             inc(NumFlds);
  942.             count := count + 1 + dbfld[NumFlds]^.FieldLen;
  943.           end;
  944.         BotX := count - 1 - dbfld[NumFlds]^.FieldLen + TopX;
  945.         dec(NumFlds);
  946.       end else BotX := dbhdr.recordlen+TopX-1+NumFlds;
  947.     if Shadow > 0 then GetText(TopX,TopY,BotX+2,BotY+1,scrn)
  948.       else GetText(TopX,TopY,BotX,BotY,scrn);
  949.     if NumFlds > 0 then
  950.       begin
  951.         DrawBox('',Single,TopX,TopY,BotX,BotY,Shadow,Border,WindC);
  952.         SetUp_Field($0E,windc,windc,$00,' ',TRUE,TRUE,_Confirm,TRUE,False,false);
  953.         size := BotY-TopY;
  954.         DispRecs := Size - 3;
  955.         textattr := WindC;
  956.         for count := 1 to BotX-TopX-2 do
  957.           writexy(count+TopX,TopY+size,'░');
  958.         writexy(BotX-1,TopY+size,'');
  959.         writexy(TopX+1,TopY+size,Chr(017));
  960.         textattr := $30;
  961.         DispFlds;
  962.         DispAllrecs;
  963.         recnum := 1;
  964.         Y := TopY+3;
  965.         gotorec(recnum);
  966.         repeat
  967.           GotoRec(recnum);
  968.           X := TopX+1;
  969.           textattr := Border;
  970.           gotoxy(x,TopY);
  971.           Str(recnum,Tstr);
  972.           write(trim_str(tstr),'/');
  973.           Str(reccount,Tstr);
  974.           write(Trim_Str(Tstr),'─────');
  975.           if BotX-TopX > 20 then
  976.             gotoxy(BotX-6,TopY); write(memavail);
  977.           textattr := Windc;
  978.           DispSingleRec(x,y,highbar,TRUE);
  979.           for count := 1 to NumFlds do
  980.             if dbfld[count]^.fieldtype = 'D' then ReplFld(count,ctod(TempStr[count]))
  981.               else ReplFld(count,TempStr[count]);
  982.           CheckKeys(x,y);
  983.         until ReturnVal = _ESC;
  984.         GotoRec(1);
  985.       end;
  986.     if Shadow > 0 then PutText(TopX,TopY,BotX+2,BotY+1,scrn)
  987.       else PutText(TopX,TopY,BotX,BotY,scrn);
  988.     textattr := OldAttr;
  989.     Gotoxy(oldx,Oldy);
  990.     end;
  991.   end;
  992.  
  993. procedure dbf.DoBrowse(X,Y: byte);
  994.   var
  995.     ylen : byte;
  996.   begin
  997.     if reccount > 0 then
  998.       begin
  999.         if reccount > (21-Y) then ylen := 20
  1000.           else ylen := reccount+y-1;
  1001.         dobrowseX('',single,X,Y,80,ylen+4,$00,$1f,$1f,$70);
  1002.       end;
  1003.   end;
  1004.  
  1005. procedure DBF.SayXY(xpos,ypos,fldnum : byte);
  1006.   begin
  1007.     WriteXY(Xpos,Ypos,GetFld(fldnum));
  1008.   end;
  1009.  
  1010. procedure DBF.GetXY(xpos,ypos,fldnum : byte;SayStr,Pix : string);
  1011.   var
  1012.     Tstr : string;
  1013.   begin
  1014.     if not _eof then
  1015.       begin
  1016.         inc(Max_Getf);
  1017.         with setcolor[1] do
  1018.          SetUp_Field(Prompt,Active,Inactive,Shadow,Clear_Chr,EscKey,
  1019.                      Clean,_Confirm,Bell,UpDn,Wndw);
  1020.         inc(DB_GetF);
  1021.         New(DB_Fstr[DB_GetF]);
  1022.         DB_Fstr[DB_GetF]^.Fnum := FldNum;
  1023.         DB_Fstr[DB_GetF]^.Fstr := GetFld(FldNum);
  1024.         Get_Rd[Max_Getf] := DBarea;
  1025.  
  1026.         if dbfld[DB_GetF]^.FieldDec < 10 then Str(dbfld[DB_GetF]^.FieldDec:1,Tstr)
  1027.           else Str(dbfld[DB_GetF]^.FieldDec:2,Tstr);
  1028.         case dbfld[DB_GetF]^.fieldtype of
  1029.           'N' : Pix := '@9:'+Tstr;
  1030.           'D' : begin
  1031.                   Pix := '@D';
  1032.                   DB_Fstr[DB_GetF]^.Fstr := dtoc(DB_Fstr[DB_GetF]^.Fstr);
  1033.                 end;
  1034.         end;
  1035.         Field_Str(xpos,ypos,dbfld[DB_GetF]^.FieldLen,SayStr,DB_Fstr[DB_GetF]^.Fstr,Pix);
  1036.       end;
  1037.   end;
  1038.  
  1039. procedure PutRead;
  1040.   var
  1041.     x,count : byte;
  1042.   begin
  1043.     x := 1;
  1044.     while Get_RD[x] > 0 do
  1045.       with SelectDB[Get_RD[x]]^ do
  1046.         begin
  1047.           for count := 1 to DB_GetF do
  1048.             begin
  1049.               if dbfld[count]^.fieldtype = 'D' then
  1050.                 ReplFld(DB_Fstr[count]^.Fnum,CTOD(DB_Fstr[count]^.Fstr))
  1051.               else ReplFld(DB_Fstr[count]^.Fnum,DB_Fstr[count]^.Fstr);
  1052.               release(DB_Fstr[count]);
  1053.             end;
  1054.           DB_GetF := 0;
  1055.           inc(x);
  1056.         end;
  1057.   end;
  1058.  
  1059. procedure ReadGet;
  1060.   var
  1061.     ReturnVal : Integer;
  1062.   begin
  1063.     Do_Fields(ReturnVal);
  1064.     PutRead;
  1065.     Max_GetF := 0;
  1066.     FillChar(Get_RD,Sizeof(Get_Rd),0);
  1067.   end;
  1068.  
  1069. begin
  1070.   Max_DB := 0;
  1071.   Max_GetF := 0;
  1072.   FillChar(Get_RD,Sizeof(Get_Rd),0);
  1073.   SetColor[1].prompt    := $1f;
  1074.   SetColor[1].active    := $30;
  1075.   SetColor[1].inactive  := $1f;
  1076.   SetColor[1].shadow    := $00;
  1077.   SetColor[1].clear_chr := ' ';
  1078.   SetColor[1].esckey    := true;
  1079.   SetColor[1].clean     := true;
  1080.   SetColor[1].confirm   := true;
  1081.   SetColor[1].bell      := true;
  1082.   SetColor[1].updn      := true;
  1083.   SetColor[1].wndw      := true;
  1084. end.